Attribute VB_Name = "modDispatchDelegator"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     OleTypes.olb (VBoost: Ole Type Definitions)
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     VBoost.Bas
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1 : VBOOST_AGGREGATEUNKNOWN = 1 : VBOOST_BLIND = 1
'   Conditional Compilation Values:
'     None
'
' This file is not discussed directly.
'***************************************************************
Option Explicit

#If False Then
'This file is used to replace VB's IDispatch implementation on a
'primary or secondary interface with an implementation based on the
'current TypeLib in the executable. This is a very sensitive operation,
'and you should follow the sample code shown here very carefully.
'If you miss any flags then the hook will fail. Do not add the adNoDelegator
'flag because that can leave you with no external reference count on the object
'despite an outstanding reference. Note that adPrimaryDispatch is of no use
'here because it resolves directly against the object before the hook is in
'place, so adPrimaryDispatch grabs the unhooked IDispatch implementation instead
'of the wrapped version. Also note that a New from the same project does not
'QueryInterface for the primary interface. This is primarily designed for externally
'created objects, which always QI.
'
'Sample usage of this file, maps the primary interface to use the typelib
'to implement IDispatch.
'
'To map a secondary interface, you only need one AggData entry instead because
'the adMapIID AggregateData is not needed.
*****Start Sample Calling Code*****
Private m_Hook As UnknownHook
Private m_DispDel As DispatchDelegator
Private Sub Class_Initialize()
Dim AggData(1) As AggregateData
Dim IIDs(1) As IID
    With AggData(0)
        Set .pObject = InitDispatchDelegator(m_DispDel, _
          LoadTypeLibEx(App.Path & "\" & App.EXEName & ".exe", REGKIND_NONE), _
          "_" & TypeName(Me), IIDs(0), Me)
        .Flags = adUseIIDs Or adBeforeHookedUnknown Or adFullyResolved
        .FirstIID = 0 'FirstIID matches IID index of IID parameter in function call
    End With
    IIDs(1) = IIDFromString(strIID_IDispatch)
    With AggData(1)
        .Flags = adMapIID
        .FirstIID = 1
        .LastIID = 0 'LastIID matches FirstIID value in the other AggData
    End With
    VBoost.AggregateUnknown Me, AggData, IIDs, m_Hook
End Sub
*****End Sample Calling Code*****
#End If

#If VBOOST_BLIND_512 Then
    Private Const cBlindVTableEntries As Long = 512
#ElseIf VBOOST_BLIND_256 Then
    Private Const cBlindVTableEntries As Long = 256
#ElseIf VBOOST_BLIND_128 Then
    Private Const cBlindVTableEntries As Long = 128
#ElseIf VBOOST_BLIND_64 Then
    Private Const cBlindVTableEntries As Long = 64
#ElseIf VBOOST_BLIND_32 Then
    Private Const cBlindVTableEntries As Long = 32
#Else
    'To further customize, change this value to whatever is appropriate for your project.
    '1024 is the highest value that is generally expected by a COM vtable. This should be
    'in sync with the value in VBoost.Bas
    Private Const cBlindVTableEntries As Long = 1024
#End If

Private Type DispVTable
    VTable(cBlindVTableEntries - 1) As Long
End Type
Private m_VTable As DispVTable
Private m_pDispVTable As Long
Private Type DispDel
    BD As BlindDelegator
    ptinfo As ITypeInfo
End Type
Private Type OwnedDispDel
    Owner As ArrayOwner
    pSA() As DispDel
End Type
Private m_DerefDispDel As OwnedDispDel

Public Type DispatchDelegator
    'BlindDelegator has five fields, plus a ptinfo
    Buffer(0 To 5) As Long
End Type

Public Function InitDispatchDelegator(DispDel As DispatchDelegator, ptlib As ITypeLib, strIID As String, IID As IID, ByVal pDispImpl As Object) As IUnknown
Dim tattr As TYPEATTR
Dim ptattr As TYPEATTRPtr
Dim ptinfo As ITypeInfo
Dim ptcomp As ITypeComp
Dim pUnk As IUnknown
    'Find the IID
    With ptlib
        If AscW(strIID) = 123 Then 'Starts with {
            IID = IIDFromString(strIID)
            Set ptinfo = .GetTypeInfoOfGuid(IID)
        Else
            .GetTypeComp.BindType strIID, 0, ptinfo, ptcomp
            ptattr = ptinfo.GetTypeAttr
            CopyMemory tattr, ByVal ptattr, LenB(tattr)
            ptinfo.ReleaseTypeAttr ptattr
            IID = tattr.Guid
        End If
    End With
    
    'Initial the vtable and dereference variable if
    'we haven't already.
    If m_pDispVTable = 0 Then
        With m_VTable
            CopyMemory .VTable(0), ByVal VBoost.BlindFunctionPointer(-1), cBlindVTableEntries * 4
            .VTable(3) = FuncAddr(AddressOf IDispatch_GetTypeInfoCount)
            .VTable(4) = FuncAddr(AddressOf IDispatch_GetTypeInfo)
            .VTable(5) = FuncAddr(AddressOf IDispatch_GetIDsOfNames)
            .VTable(6) = FuncAddr(AddressOf IDispatch_Invoke)
            m_pDispVTable = VarPtr(.VTable(0))
        End With
        With m_DerefDispDel
            InitArrayOwner .Owner, LenB(.pSA(0)), 0
        End With
    End If
    
    'Fill in the BlindDelegator structure manually. Both the pInner and
    'pOuter slots are stored as weak references. A Set assignment is used
    'to force pOuter to be the controlling IUnknown. The weak references
    'are cleared before VBoost frees them using the custom pfnDestroy function.
    With m_DerefDispDel
        .Owner.SA.pvData = VarPtr(DispDel)
        With .pSA(0)
            Set .ptinfo = ptinfo
            With .BD
                .pVTable = m_pDispVTable
                .cRefs = 1
                'Put weak references in both slots
                Set pUnk = pDispImpl
                VBoost.Assign .pOuter, pUnk
                VBoost.Assign .pInner, pDispImpl
                .pfnDestroy = FuncAddr(AddressOf DestroyDispDel)
            End With
        End With
        VBoost.Assign InitDispatchDelegator, .Owner.SA.pvData
    End With
End Function
Private Function IDispatch_GetTypeInfoCount(This As DispDel, pctinfo As UINT) As Long
    pctinfo = 1
End Function
Private Function IDispatch_GetTypeInfo(This As DispDel, ByVal iTInfo As UINT, ByVal LCID As LCID, ppTInfo As ITypeInfo) As Long
    VBoost.AssignZero ppTInfo
    Set ppTInfo = This.ptinfo
End Function
Private Function IDispatch_GetIDsOfNames(This As DispDel, riid As IID, ByVal rgszNames As LPOLESTRArrayPtr, ByVal cNames As UINT, ByVal LCID As LCID, ByVal rgDispId As DISPIDArrayPtr) As Long
    IDispatch_GetIDsOfNames = DispGetIDsOfNames(This.ptinfo, rgszNames, cNames, rgDispId)
End Function
Private Function IDispatch_Invoke(This As DispDel, ByVal dispidMember As MEMBERID, riid As IID, ByVal LCID As LCID, ByVal wFlags As WORD, pDispParams As VBDISPPARAMS, ByVal pVarResult As VARIANTPtr, pExcepInfo As VBEXCEPINFO, puArgErr As UINT) As Long
Dim pObj As Long
    'Use VBoost.Assign instead of ObjPtr to save an AddRef/Release cycle.
    VBoost.Assign pObj, This.BD.pInner
    IDispatch_Invoke = DispInvoke(pObj, This.ptinfo, dispidMember, wFlags, pDispParams, pVarResult, pExcepInfo, puArgErr)
End Function
Private Function DestroyDispDel(DispDel As DispDel, pInner As Long, pOuter As IUnknownUnrestricted) As Long
    'This function is playing games with the incoming parameters. Both of these
    'are properly typed as IUnknown. All we want to do with pInner is zero out
    'the value without changing its reference count, so it is changed to a ByRef Long.
    'pOuter is changed to an IUnknownUnrestricted so that we can call AddRef, allowing
    'VBoost to call Release and get an accurate reference count. The return value is
    'only used if ppOuter is Nothing on return.
    pInner = 0
    pOuter.AddRef
    Set DispDel.ptinfo = Nothing
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function
